#!/usr/bin/perl -w
# vim:tw=100 sw=2 expandtab ft=perl
# Retrieve the configuration and install rollout locally.
#
# Example global configuration:
# rollout => {
#   require_reason => 1,               # A reason for running rollout must be given on the command line
#   logfile => "/var/log/rollout.log", # Log each run to this file
#   reorder_steps => [                 # Change the order of steps
#     "240-dir_check" => 140,
#     "060-ssh_keys" => 170,
#   ],
#   copy_steps => [                    # Run a step multiple times during the run
#     "800-file_append" => 850,
#     "800-file_append" => 880,
#   ],
# },
# command => [
#   200 => 'ls /tmp',
#   210 => sub { l "Hello world" },
# ],
#
# Available skip_steps items:
#  local_install - Install rollout locally (in /usr/local/sbin)

use vars qw( %networks );

my $global_safe_mode = $safe_mode;
# This first step has to be done without safe mode
local $safe_mode = 0;

my $machines_data = http_file "rollout.cfg";
carp "Can't retrieve rollout configuration rollout.cfg: $@" unless $machines_data;

eval $machines_data;
die "Can't parse rollout configuration rollout.cfg: $@" unless keys %m;

get_fragments("fragments"); #{{{
sub get_fragments {
  my ($location) = @_;
  my @fragments = http_index $location;
  foreach my $fragment (sort @fragments) {
    if ($fragment =~ /\/$/) {
      # making the output look pretty in verbose
      $fragment =~ s/\/$//;
      get_fragments("$location/$fragment");
    } else {
      v "fragment: $location/$fragment";
      my $text = http_file "$location/$fragment";
      if (!defined($text)) {
        w "Empty config fragment \"$location/$fragment\"";
        next;
      }
      eval $text;
      if ($@) {
        fatal "Config fragment \"$location/$fragment\" failed: $@";
      }
    }
  }
}
#}}}

v "Evaluated Rollout config: ". scalar(grep /^[a-z]/, keys %m). " devices, ".
  scalar(grep /^[A-Z]/, keys %m). " classes";
fatal "Can't find configuration entry for $hostname" unless $m{$hostname};

# Install rollout locally, keeping the rollout URL parameter permanently {{{
if (i_should("local_install")) {
  my $rollout = http_file "/rollout";
  fatal "Can't download rollout to install locally" unless $rollout;

  $rollout =~ s/^\$rollout_url = ".+?";/\$rollout_url = "$rollout_url";/m;
  my($rc, @output) = compile_perl($rollout);
  if ($rc) {
    l map { "$_\n" } @output;
    fatal "The rollout script could be not correctly parsed, and won't be installed";
    exit;
  }

  if (text_install(-file => "/usr/local/sbin/rollout", -text => $rollout, -mode => 0750,
                   -uid => 0, -group => 0 )) {
    # rollout has been updated, switch to it
    l "rollout has been updated, re-executing";
    exec("/usr/local/sbin/rollout", @original_argv);
  }
}

# }}}

push @skip_steps, flatten_list(c("$hostname/skip_steps"));
if (c("$hostname/rollout/require_reason") &&
    (!$rollout_comment || $rollout_comment eq 'No comment specified') &&
    !$global_safe_mode) {
  # A comment is required, fail if none was provided
  fatal "You must enter a reason for this rollout run on the command line."
}

# Look for any "command" blocks and queue the commands
my @commands = flatten_list(c("$hostname/command"));
for (my $i = 0; $i < @commands; $i += 2) {
  my($prio, $cmd) = @commands[$i..$i + 1];
  $steps->insert(ref $cmd ? $cmd : sub { command($cmd) }, $prio);
}


# Build networks map {{{
sub _expand_network {
  my($network) = @_;
  return () unless $network;

  $network =~ s/(^\[|\]$)//g;
  return ($network) if $network =~ /^\d+\.\d+\.\d+\.\d+/;

  my @hosts;

  foreach my $d (keys %m) {
    next unless $m{$d}->{interfaces};
    next unless $m{$d}->{network} && grep { $_ eq $network } @{$m{$d}->{network}};

    foreach (values %{$m{$d}->{interfaces}}) {
      push @hosts, $_->{ip} if $_->{ip};
    }
  }
  return @hosts;
}

foreach (keys %m) {
  $m{$_}->{network} = [ $m{$_}->{network} ]
    if $m{$_}->{network} && ref $m{$_}->{network} ne 'ARRAY';
}

foreach my $n (map { $_->{network} } grep { $_->{network} } values %m) {
  foreach my $network (@$n) {
    $networks{$network} ||= [];
    foreach my $host (_expand_network($network)) {
      push @{$networks{$network}}, $host unless grep { $_ eq $host } @{$networks{$network}};
    }
  }
}

foreach my $d (grep { $m{$_}->{ISA} } keys %m) {
  next unless $m{$d}->{interfaces};
  foreach (i_isa_classes($d)) {
    $networks{$_} ||= [];
    foreach my $i (values %{$m{$d}->{interfaces}}) {
      push @{$networks{$_}}, $i->{ip} if $i->{ip};
    }
  }

  foreach my $i (values %{$m{$d}->{interfaces}}) {
    next unless $i->{ip};
    $networks{$d} ||= [];
    push @{$networks{$d}}, $i->{ip};
  }
}

# }}}
sub compile_perl { # {{{
  my($code) = @_;
  my $pid;

  use POSIX ":sys_wait_h";
  use IPC::Open2;

  local $SIG{CHLD} = sub {
    waitpid(-1, WNOHANG);
    $pid = 0;
  };

  my($rd, $wr);
  $pid = open2($rd, $wr, "$^X -wc - 2>&1");
  print $wr $code;
  close $wr;
  my @output;
  while (<$rd>) {
    chomp;
    push @output, $_;
  }
  close($wr);

  pop @output if @output && $output[$#output] =~ /^- (?:syntax OK|had compilation errors)/;

  while ($pid) {sleep(1)}

  return wantarray ? ($?, @output) : $?;
}
# }}}
